home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / attributes.pm < prev    next >
Encoding:
Perl POD Document  |  2009-10-01  |  2.2 KB  |  94 lines
  1. package attributes;
  2.  
  3. our $VERSION = 0.08;
  4.  
  5. @EXPORT_OK = qw(get reftype);
  6. @EXPORT = ();
  7. %EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
  8.  
  9. use strict;
  10.  
  11. sub croak {
  12.     require Carp;
  13.     goto &Carp::croak;
  14. }
  15.  
  16. sub carp {
  17.     require Carp;
  18.     goto &Carp::carp;
  19. }
  20.  
  21. ## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{}
  22. #sub reftype ($) ;
  23. #sub _fetch_attrs ($) ;
  24. #sub _guess_stash ($) ;
  25. #sub _modify_attrs ;
  26. #
  27. # The extra trips through newATTRSUB in the interpreter wipe out any savings
  28. # from avoiding the BEGIN block.  Just do the bootstrap now.
  29. BEGIN { bootstrap attributes }
  30.  
  31. sub import {
  32.     @_ > 2 && ref $_[2] or do {
  33.     require Exporter;
  34.     goto &Exporter::import;
  35.     };
  36.     my (undef,$home_stash,$svref,@attrs) = @_;
  37.  
  38.     my $svtype = uc reftype($svref);
  39.     my $pkgmeth;
  40.     $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
  41.     if defined $home_stash && $home_stash ne '';
  42.     my @badattrs;
  43.     if ($pkgmeth) {
  44.     my @pkgattrs = _modify_attrs($svref, @attrs);
  45.     @badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
  46.     if (!@badattrs && @pkgattrs) {
  47.             require warnings;
  48.         return unless warnings::enabled('reserved');
  49.         @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
  50.         if (@pkgattrs) {
  51.         for my $attr (@pkgattrs) {
  52.             $attr =~ s/\(.+\z//s;
  53.         }
  54.         my $s = ((@pkgattrs == 1) ? '' : 's');
  55.         carp "$svtype package attribute$s " .
  56.             "may clash with future reserved word$s: " .
  57.             join(' : ' , @pkgattrs);
  58.         }
  59.     }
  60.     }
  61.     else {
  62.     @badattrs = _modify_attrs($svref, @attrs);
  63.     }
  64.     if (@badattrs) {
  65.     croak "Invalid $svtype attribute" .
  66.         (( @badattrs == 1 ) ? '' : 's') .
  67.         ": " .
  68.         join(' : ', @badattrs);
  69.     }
  70. }
  71.  
  72. sub get ($) {
  73.     @_ == 1  && ref $_[0] or
  74.     croak 'Usage: '.__PACKAGE__.'::get $ref';
  75.     my $svref = shift;
  76.     my $svtype = uc reftype $svref;
  77.     my $stash = _guess_stash $svref;
  78.     $stash = caller unless defined $stash;
  79.     my $pkgmeth;
  80.     $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
  81.     if defined $stash && $stash ne '';
  82.     return $pkgmeth ?
  83.         (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
  84.         (_fetch_attrs($svref))
  85.     ;
  86. }
  87.  
  88. sub require_version { goto &UNIVERSAL::VERSION }
  89.  
  90. 1;
  91. __END__
  92. #The POD goes here
  93.  
  94.